home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / link / sparc_link.t < prev    next >
Encoding:
Text File  |  1989-07-06  |  11.8 KB  |  320 lines
  1. (herald sparc_link (env t (link defs)))
  2.  
  3. (define (define-null-descriptor heap)
  4.   (modify (area-frontier heap)
  5.           (lambda (x) (fx+ (fx+ x %%slink-size) %%stack-size)))
  6.   (set *null-descriptor*
  7.        (object nil
  8.          ((heap-stored self) heap)
  9.          ((heap-offset self) (fx+ %%stack-size tag/pair))
  10.          ((write-descriptor self stream)
  11.           (write-data stream (fx+ %%stack-size tag/pair)))
  12.          ((write-store self stream) 
  13.       (do ((i 0 (fx+ i 4)))
  14.           ((fx= i %%stack-size))
  15.         (write-int stream 0))
  16.           (let ((pi (fx+ slink/initial-pure-memory-begin 3)))
  17.             (do ((i 0 (fx+ i 4)))
  18.                 ((fx= i pi)
  19.                  (write-int stream 0)
  20.                  (write-int stream (area-frontier (lstate-pure *lstate*)))
  21.                  (write-data stream %%stack-size)
  22.                  (write-data stream (area-frontier (lstate-impure *lstate*)))
  23.                  (do ((i (fx+ i 16) (fx+ i 4)))
  24.                      ((fx= i %%slink-size))
  25.                    (write-int stream 0)))
  26.               (write-int stream 0))))))
  27.   (push (area-objects heap) *null-descriptor*)
  28.   (set-table-entry *reloc-table* nil *null-descriptor*)
  29.   (reloc-thunk (object nil
  30.          ((heap-stored self) (lstate-pure *lstate*))
  31.          ((write-descriptor self stream)
  32.           (write-int stream 0)))
  33.            (fx+ %%stack-size
  34.             (fx+ slink/initial-pure-memory-begin 3)))
  35.   (reloc-thunk (object nil
  36.          ((heap-stored self) (lstate-pure *lstate*))
  37.          ((write-descriptor self stream)
  38.           (write-int stream (area-frontier (lstate-pure *lstate*)))))
  39.            (fx+ %%stack-size (fx+ slink/initial-pure-memory-end 3)))
  40.   (reloc-thunk (object nil
  41.          ((heap-stored self) (lstate-impure *lstate*))
  42.          ((write-descriptor self stream)
  43.           (write-data stream %%stack-size)))
  44.            (fx+ %%stack-size
  45.             (fx+ slink/initial-impure-memory-begin 3)))
  46.   (reloc-thunk (object nil
  47.          ((heap-stored self) (lstate-impure *lstate*))
  48.          ((write-descriptor self stream)
  49.           (write-data stream (area-frontier (lstate-impure *lstate*)))))
  50.            (fx+ %%stack-size
  51.             (fx+ slink/initial-impure-memory-end 3))))
  52.  
  53. (define (vgc-copy-vcell vcell)
  54.   (let* ((heap (lstate-impure *lstate*))
  55.          (addr (area-frontier heap))
  56.          (var (vcell-struct-var vcell))
  57.          (desc (object nil
  58.                  ((heap-stored self) (lstate-impure *lstate*))
  59.                  ((heap-offset self) addr)   
  60.                  ((write-descriptor self stream)
  61.                   (write-data stream (fx+ addr tag/extend)))
  62.                  ((write-store self stream)
  63.           (write-vcell-header var stream)
  64.                   (write-var-ref stream var)
  65.                   (write-data stream (fx+ addr 22)) 
  66.                   (write-slot (var-node-name var) stream)
  67.           (write-data stream (fx+ addr 30))
  68.                   (write-int stream header/weak-alist)
  69.                   (write-slot (var-node-refs var) stream)
  70.                   (write-int stream header/weak-alist)
  71.                   (write-slot (var-node-vcell-refs var) stream)))))
  72.     (set (area-frontier heap) (fx+ addr (fx* CELL 9)))  ; 5 for vcell
  73.     (set-table-entry *reloc-table* vcell desc)          ; 4 for weak-alists
  74.     (push (area-objects heap) desc) 
  75.     (relocate-unit-variable var (fx+ addr CELL) t)
  76.     (set (var-node-refs var) (a-list->vector (var-node-refs var)))
  77.     (set (var-node-vcell-refs var) (a-list->vector (var-node-vcell-refs var)))
  78.     (generate-slot-relocation (var-node-refs var) (fx+ addr (fx* CELL 6)))
  79.     (generate-slot-relocation (var-node-vcell-refs var) (fx+ addr (fx* CELL 8)))
  80.     (generate-slot-relocation (var-node-name var) (fx+ addr (fx* CELL 3)))
  81.     (reloc-thunk (object nil
  82.            ((heap-stored self) (lstate-impure *lstate*))
  83.            ((write-descriptor self stream)
  84.             (write-data stream (fx+ addr 22))))
  85.          (fx+ addr (fx* CELL 2)))
  86.     (reloc-thunk (object nil
  87.            ((heap-stored self) (lstate-impure *lstate*))
  88.            ((write-descriptor self stream)
  89.             (write-data stream (fx+ addr 30))))
  90.          (fx+ addr (fx* CELL 4)))
  91.     desc))
  92.  
  93. ;;; Look at a Unix a.out description and template.doc
  94.  
  95. (define (link modules out-spec)
  96.   (really-link modules 'so out-spec 'o))
  97.  
  98. (define-constant %%d-ieee-size 53)
  99. (define-constant %%d-ieee-excess 1023)
  100.  
  101. (define (write-double-float stream float)
  102.   (receive (sign mantissa exponent)
  103.            (normalized-float-parts float
  104.                                    %%d-ieee-size 
  105.                                    %%d-ieee-excess 
  106.                                    t)
  107.     (write-int stream header/double-float)
  108.     (write-half stream (fx+ (fixnum-ashl sign 15)
  109.                             (fx+ (fixnum-ashl exponent 4)
  110.                                  (bignum-bit-field mantissa 48 4))))
  111.     (write-half stream (bignum-bit-field mantissa 32 16)) 
  112.     (write-half stream (bignum-bit-field mantissa 16 16)) 
  113.     (write-half stream (bignum-bit-field mantissa 0 16))))
  114.   
  115. (define (write-vcell-header var stream)
  116.   (write-half stream 0)
  117.   (write-byte stream (if (fx= (vector-length (var-node-refs var))
  118.                   0)
  119.              0
  120.              -1))
  121.   (write-byte stream (if (eq? (var-node-defined var) 'define)
  122.              (fx+ header/vcell 128)
  123.              header/vcell)))
  124.  
  125. (define-constant RELOC-SIZE 12)
  126. (define-constant CYMBAL-SIZE 12)
  127. (define-constant OMAGIC #o407)
  128. (define-constant N_TEXT 4)
  129. (define-constant N_DATA 6)
  130. (define-constant N_UNDF 0)
  131. (define-constant N_EXT 1)
  132.  
  133.  
  134. (define (vgc-copy-foreign foreign)
  135.   (let* ((heap (lstate-impure *lstate*))
  136.          (addr (area-frontier heap))
  137.          (name (foreign-object-name foreign))
  138.          (desc (object nil
  139.                  ((heap-stored self) (lstate-impure *lstate*))
  140.                  ((heap-offset self) addr)
  141.                  ((write-descriptor self stream)
  142.                   (write-data stream (fx+ addr tag/extend)))
  143.                  ((write-store self stream)
  144.                   (write-int stream header/foreign)
  145.                   (write-slot name stream)
  146.                   (write-int stream 0)))))
  147.     (set (area-frontier heap) (fx+ addr 12))
  148.     (set-table-entry *reloc-table* foreign desc)
  149.     (generate-slot-relocation name (fx+ addr 4))
  150.     (push (area-objects heap) desc)                
  151.     (cymbal-thunk (string-append "_" (symbol->string name))
  152.           (fixnum-logior N_UNDF N_EXT) 0)
  153.     (reloc-thunk (fixnum-logior (fixnum-ashl (lstate-symbol-count *lstate*) 8)
  154.                                 #x82)
  155.                  (fx+ addr 8))
  156.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  157.     desc))
  158.  
  159. (define (relocate-unit-variable var addr external?)
  160.   (let ((area (lstate-impure *lstate*))
  161.         (type (var-value-type var)))
  162.    (cond (type
  163.     (cond ((and external? (neq? (var-node-value var) NONVALUE))
  164.            (cymbal-thunk (string-downcase! (symbol->string (var-node-name var)))
  165.                          (fixnum-logior N_DATA N_EXT)
  166.                          (unit-var-value (var-node-value var)))
  167.            (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
  168.     (reloc-thunk type addr)))))
  169.  
  170.  
  171. (define (var-value-type var)
  172.   (let ((value (var-node-value var)))
  173.     (cond ((eq? value NONVALUE) 
  174.            (vgc (var-node-name var))
  175.            nil)
  176.           ((unit-loc? value) value)
  177.           (else (vgc value)))))
  178.  
  179.  
  180. (define (generate-slot-relocation obj slot-address)
  181.   (cond ((or (fixnum? obj) (char? obj) (eq? obj '#t)))
  182.     (else
  183.      (reloc-thunk (vgc obj) slot-address))))
  184.  
  185.  
  186. (define (reloc-thunk type address)
  187.   (push (lstate-data-reloc *lstate*)
  188.         (cons address type)))
  189.  
  190. (define (cymbal-thunk stryng type value)
  191.  (push (lstate-symbols *lstate*)
  192.   (object (lambda (stream a)
  193.             ;; a is offset into stryng table
  194.             (write-int stream a)
  195.             (write-byte stream type)
  196.             (write-byte stream 0)       ; other
  197.             (write-half stream 0)       ; see <stab.h>                 
  198.             (if (fx= type 1)            ; undefined external (foreign)
  199.                 (write-int stream 0)
  200.                 (write-data stream value)))
  201.           ((cymbal-thunk.stryng self) stryng))))
  202.  
  203. (define-operation (cymbal-thunk.stryng thunk))
  204.  
  205. (lset pure-size nil)
  206.  
  207. (define (write-slot obj stream)
  208.   (cond ((table-entry *reloc-table* obj)
  209.          => (lambda (desc) (write-descriptor desc stream)))
  210.         ((fixnum? obj)
  211.          (write-fixnum stream obj))
  212.         ((char? obj)
  213.          (write-int stream (fx+ (fixnum-ashl (char->ascii obj) 8)
  214.                                  header/char)))
  215.         ((eq? obj '#t)
  216.          (write-int stream header/true))
  217.         (else
  218.          (error "bad immediate type ~s" obj))))
  219.  
  220. (define-integrable (write-data stream int)
  221.   (write-int stream (fx+ pure-size int)))
  222.  
  223. (define-integrable (write-int stream int)
  224.   (write-half stream (fixnum-ashr int 16))
  225.   (write-half stream int))
  226.  
  227. (define (write-half stream int)
  228.   (write-byte stream (fixnum-ashr int 8))
  229.   (write-byte stream int))
  230.  
  231. (define-integrable (write-byte stream n)
  232.   (writec stream (ascii->char (fixnum-logand n 255))))
  233.                                  
  234. (define-integrable (write-fixnum stream fixnum)
  235.   (write-half stream (fixnum-ashr fixnum 14))
  236.   (write-half stream (fixnum-ashl fixnum 2)))
  237.  
  238.  
  239. (define (write-link-file stream)
  240.   (pad-area (lstate-pure *lstate*))
  241.   (pad-area (lstate-impure *lstate*))
  242.   (set pure-size (area-frontier (lstate-pure *lstate*)))
  243.   (write-header     stream)
  244.   (write-area       stream (lstate-pure *lstate*))
  245.   (write-area       stream (lstate-impure *lstate*))
  246.   (write-relocation stream (lstate-data-reloc *lstate*))  
  247.   (write-cymbal&stryng-table stream (reverse (lstate-symbols *lstate*))))
  248.  
  249. (define (write-header stream)
  250.   (let* ((text-size (area-frontier (lstate-pure *lstate*)))
  251.          (data-size (area-frontier (lstate-impure *lstate*))))
  252.     (write-half stream #x0103)        ; only on sparc
  253.     (write-half stream OMAGIC)                ;magic number
  254.     (write-int stream text-size)              ;text segment size
  255.     (write-int stream data-size)              ;data segment size
  256.     (write-int stream 0)                      ;bss  segment size
  257.     (write-int stream (fx* CYMBAL-SIZE (lstate-symbol-count *lstate*)))
  258.     (write-int stream 0)                      ;bogus entry point
  259.     (write-int stream 0)                      ; no text relocation
  260.     (write-int stream (fx* (length (lstate-data-reloc *lstate*)) RELOC-SIZE))))
  261.  
  262. (define (write-area stream area)
  263.   (walk (lambda (x) (write-store x stream))
  264.         (reverse! (area-objects area))))
  265.  
  266.  
  267. (define (write-relocation stream items)
  268.   (walk (lambda (item)
  269.       (let ((addr (car item))
  270.         (desc (cdr item)))
  271.           (write-int stream (car item))
  272.       (cond ((fixnum? desc)
  273.          (write-int stream desc)
  274.          (write-int stream 0))
  275.         ((unit-loc? desc)
  276.          (write-int stream #x602)
  277.          (write-unit-loc stream desc))
  278.         ((eq? (heap-stored desc) (lstate-pure *lstate*))
  279.          (write-int stream #x402)
  280.          (write-descriptor desc stream))
  281.         (else
  282.          (write-int stream #x602)
  283.          (write-descriptor desc stream)))))         
  284.         (sort-list! items
  285.                     (lambda (x y)      
  286.                        (fx< (car x) (car y))))))
  287.           
  288.                              
  289. (define (write-map-entry stream name value) nil)
  290.  
  291. (define (write-cymbal&stryng-table stream cyms)
  292.   (let ((z (write-cyms stream cyms))) ; cymbal table
  293.     (write-int stream z)       ; size of stryng table
  294.     (walk (lambda (s)             ; write stryng table
  295.             (write-string stream (cymbal-thunk.stryng s))
  296.             (write-byte stream 0))
  297.            cyms)))
  298.  
  299. (define (write-cyms stream cyms)
  300.   (iterate loop ((a 4)                      ;; 4 bytes for size of stryng table
  301.                  (l cyms))
  302.     (cond ((null? l) a)
  303.           (else
  304.            (let ((e (car l)))
  305.              (e stream a)
  306.              (loop (fx+ (fx+ a (string-length (cymbal-thunk.stryng e))) 1) ;null
  307.                    (cdr l)))))))
  308.  
  309.  
  310. (define (pad-area area)
  311.   (let ((rem (fixnum-remainder (area-frontier area) 16)))
  312.     (cond ((fxn= rem 0)
  313.        (modify (area-frontier area)
  314.            (lambda (x) (fx+ x (fx- 16 rem))))
  315.        (do ((i (fx- 16 rem) (fx- i 4)))
  316.            ((fx= i 0))
  317.          (push (area-objects area)
  318.            (object nil
  319.              ((write-store self stream)
  320.               (write-int stream 0)))))))))